COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(declare (fasload meter)(setq meter:count-only t))
C00009 ENDMK
C⊗;
(declare (fasload meter)(setq meter:count-only t))
(declare (setq objects-of-interest '
	       ((eq "Eq's")(car "Car's" car)(caar "Car's" car 2)
			   (rplaca "Rplaca's") (rplacd "Rplacd's")
			   (cdr "Cdr's" cdr) (= "='s")(1- "1-'s")(1+ "1+'s")
			   (null "Null's")(cons "Conses" cons)(add "ADD")
			   (snb "SNB")
			   (remove "REMOVE")(find-root "FIND-ROOT")
			   (select "SELECT")(push "CONSES" cons 1)
			   (random "RANDOM")(setf "Setf's")(travers "TRAVERS"))))
;;; Benchmark to create once and traverse a Structure
(declare  (fasload struct fas dsk (mac lsp)))

(defstruct node
	   (parents ())
	   (sons ())
	   (sn (snb))
	   (entry1 ())
	   (entry2 ())
	   (entry3 ())
	   (entry4 ())
	   (entry5 ())
	   (entry6 ())
	   (mark ()))

(declare (special sn))
(setq sn 0)

(defmacro mod (x n) `(remainder ,x ,n))

(declare (special rand)(fixnum rand))
(setq rand 21.)

(defun seed () (setq rand 21.))

(defun random () (setq rand (mod (* rand 17.) 251.)))

(meter:meter traverse
 (meter-funs #.objects-of-interest
	     (defun snb () (setq sn (1+ sn))))

(meter-funs #.objects-of-interest
(defun remove (n q)
       (cond ((eq (cdr (car q)) (car q))
	      (prog2 () (caar q) (rplaca q ())))
	     ((= n 0)
	      (prog2 () (caar q)
		     (do ((p (car q) (cdr p)))
			 ((eq (cdr p) (car q))
			  (rplaca q
				  (rplacd p (cdr (car q))))))))
	     (t (do ((n n (1- n))
		     (q (car q) (cdr q))
		     (p (cdr (car q)) (cdr p)))
		    ((= n 0) (prog2 () (car q) (rplacd q p))))))))

(meter-funs #.objects-of-interest
(defun select (n q)
       (do ((n n (1- n))
	    (q (car q) (cdr q)))
	   ((= n 0) (car q)))))

(meter-funs #.objects-of-interest
(defun add (a q)
       (cond ((null q)
	      `(,(let ((x `(,a)))
		      (rplacd x x) x)))
	     ((null (car q))
	      (let ((x `(,a)))
		   (rplacd x x)
		   (rplaca q x)))
	     (t (mn "Conses" cons 1)
		(rplaca q
			(rplacd (car q) `(,a .,(cdr (car q)))))))))

(meter-funs #.objects-of-interest
(defun create-structure (n)
       (let ((a `(,(make-node))))
	    (do ((m (1- n) (1- m))
		 (p a))
		((= m 0) (mn "Conses" cons 1)
			 (setq a `(,(rplacd p a)))
			 (do ((unused a)
			      (used (add (remove 0 a) ()))
			      (x) (y))
			     ((null (car unused))
			      (find-root (select 0 used) n))
			     (setq x (remove (mod (random) n) unused))
			     (setq y (select (mod (random) n) used))
			     (add x used)
			     (mn "CONSES" cons 2)
			     (mn "PARENTS" parents 1)
			     (mn "SONS" sons 1)
			     (setf (sons y) `(,x .,(sons y)))
			     (setf (parents x) `(,y .,(parents x))) ))
		(push (make-node) a)))))

(meter-funs #.objects-of-interest
(defun find-root (node n)
 (do ((n n (1- n)))
     ((= n 0) node)
     (mn "PARENTS" parents 1)
     (cond ((null (parents node))
	    (return node))
	   (t (mn "PARENTS" parents 1)
	      (setq node (car (parents node))))))))

(declare (special count marker))

(setq count 0 marker ())

(meter-funs #.objects-of-interest
(defun travers (node mark)
       (mn "MARK" mark 1)
       (cond ((eq (mark node) mark) ())
	     (t (mn "MARK" mark 1)
		(setf (mark node) mark)
		(setq count (1+ count))
		(mn "ENTRY1" entry1 1)
		(mn "ENTRY2" entry2 1)
		(mn "ENTRY3" entry3 1)
		(mn "ENTRY4" entry4 1)
		(mn "ENTRY5" entry5 1)
		(mn "ENTRY6" entry6 1)
		(setf (entry1 node) (not (entry1 node)))
		(setf (entry2 node) (not (entry2 node)))
		(setf (entry3 node) (not (entry3 node)))
		(setf (entry4 node) (not (entry4 node)))
		(setf (entry5 node) (not (entry5 node)))
		(setf (entry6 node) (not (entry6 node)))
		(do ((sons (sons node) (cdr sons)))
		    ((null sons) ())
		    (travers (car sons) mark)))))))

(defun traverse (root)
       (let ((count 0))
	    (travers root (setq marker (not marker)))
	    count)) 

(declare (special root))
(defun init ()
       (prog2 (setq root (create-structure 100.)) ()))  

(*rset (nouuo ()))